home *** CD-ROM | disk | FTP | other *** search
/ AGA Toolkit '97 / The AGA Toolkit '97.iso / miscellaneous / science / maths / calc / source / opcodes.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-09-07  |  51.4 KB  |  2,652 lines
  1. /*
  2.  * Copyright (c) 1994 David I. Bell
  3.  * Permission is granted to use, distribute, or modify this source,
  4.  * provided that this copyright notice remains intact.
  5.  *
  6.  * Modified for the Amiga by Steve Leblanc, Sept 1995
  7.  *
  8.  * Opcode execution module
  9.  */
  10.  
  11. #include "stdarg.h"
  12. #include "calc.h"
  13. #include "opcodes.h"
  14. #include "func.h"
  15. #include "symbol.h"
  16.  
  17. #define    QUICKLOCALS    20        /* local vars to handle quickly */
  18.  
  19.  
  20. VALUE *stack;                /* current location of top of stack */
  21. static VALUE stackarray[MAXSTACK];    /* storage for stack */
  22. static VALUE oldvalue;            /* previous calculation value */
  23. static char *funcname;            /* function being executed */
  24. static long funcline;            /* function line being executed */
  25.  
  26. FLAG traceflags;            /* current trace flags */
  27. int tab_ok = TRUE;            /* FALSE => don't print lading tabs */
  28.  
  29.  
  30. /*
  31.  * Routine definitions
  32.  */
  33. static void o_nop(), o_localaddr(), o_globaladdr(), o_paramaddr();
  34. static void o_globalvalue(), o_paramvalue(), o_number(), o_indexaddr();
  35. static void o_assign(), o_add(), o_sub(), o_mul(), o_div();
  36. static void o_mod(), o_save(), o_negate(), o_invert(), o_int(), o_frac();
  37. static void o_numerator(), o_denominator(), o_duplicate(), o_pop();
  38. static void o_jumpeq(), o_jumpne(), o_jump(), o_usercall(), o_getvalue();
  39. static void o_eq(), o_ne(), o_le(), o_ge(), o_lt(), o_gt(), o_preinc();
  40. static void o_postinc(), o_postdec(), o_debug(), o_print(), o_assignpop();
  41. static void o_zero(), o_one(), o_printeol(), o_printspace(), o_printstring();
  42. static void o_oldvalue(), o_quo(), o_power(), o_quit(), o_call(), o_swap();
  43. static void o_dupvalue(), o_getepsilon(), o_and(), o_or(), o_not();
  44. static void o_abs(), o_sgn(), o_isint(), o_condorjump(), o_condandjump();
  45. static void o_square(), o_string(), o_isnum(), o_undef(), o_isnull();
  46. static void o_matcreate(), o_ismat(), o_isstr(), o_getconfig(), o_predec();
  47. static void o_leftshift(), o_rightshift(), o_casejump();
  48. static void o_isodd(), o_iseven(), o_fiaddr(), o_fivalue(), o_argvalue();
  49. static void o_isreal(), o_imaginary(), o_re(), o_im(), o_conjugate();
  50. static void o_objcreate(), o_isobj(), o_norm(), o_elemaddr(), o_elemvalue();
  51. static void o_istype(), o_scale(), o_localvalue(), o_return(), o_islist();
  52. static void o_issimple(), o_cmp(), o_quomod(), o_setconfig(), o_setepsilon();
  53. static void o_printresult(), o_isfile(), o_isassoc(), o_eleminit();
  54.  
  55.  
  56. /*
  57.  * Types of opcodes (depends on arguments saved after the opcode).
  58.  */
  59. #define OPNUL    1    /* opcode has no arguments */
  60. #define OPONE    2    /* opcode has one integer argument */
  61. #define OPTWO    3    /* opcode has two integer arguments */
  62. #define OPJMP    4    /* opcode is a jump (with one pointer argument) */
  63. #define OPRET    5    /* opcode is a return (with no argument) */
  64. #define OPGLB    6    /* opcode has global symbol pointer argument */
  65. #define OPPAR    7    /* opcode has parameter index argument */
  66. #define OPLOC    8    /* opcode needs local variable pointer (with one arg) */
  67. #define OPSTR    9    /* opcode has a string constant arg */
  68. #define OPARG    10    /* opcode is given number of arguments */
  69. #define    OPSTI    11    /* opcode is static initialization */
  70.  
  71.  
  72. /*
  73.  * Information about each opcode.
  74.  */
  75. static struct opcode {
  76.     void (*o_func)();    /* routine to call for opcode */
  77.     int o_type;        /* type of opcode */
  78.     char *o_name;        /* name of opcode */
  79. } opcodes[MAX_OPCODE+1] = {
  80.     o_nop,        OPNUL,  "NOP",        /* no operation */
  81.     o_localaddr,    OPLOC,  "LOCALADDR",    /* address of local variable */
  82.     o_globaladdr,    OPGLB,  "GLOBALADDR",    /* address of global variable */
  83.     o_paramaddr,    OPPAR,  "PARAMADDR",    /* address of paramater variable */
  84.     o_localvalue,    OPLOC,  "LOCALVALUE",    /* value of local variable */
  85.     o_globalvalue,    OPGLB,  "GLOBALVALUE",    /* value of global variable */
  86.     o_paramvalue,    OPPAR,  "PARAMVALUE",     /* value of paramater variable */
  87.     o_number,    OPONE,  "NUMBER",    /* constant real numeric value */
  88.     o_indexaddr,    OPTWO,  "INDEXADDR",    /* array index address */
  89.     o_printresult,    OPNUL,  "PRINTRESULT",    /* print result of top-level expression */
  90.     o_assign,    OPNUL,  "ASSIGN",    /* assign value to variable */
  91.     o_add,        OPNUL,  "ADD",        /* add top two values */
  92.     o_sub,        OPNUL,  "SUB",        /* subtract top two values */
  93.     o_mul,        OPNUL,  "MUL",        /* multiply top two values */
  94.     o_div,        OPNUL,  "DIV",        /* divide top two values */
  95.     o_mod,        OPNUL,  "MOD",        /* take mod of top two values */
  96.     o_save,        OPNUL,  "SAVE",        /* save value for later use */
  97.     o_negate,    OPNUL,  "NEGATE",    /* negate top value */
  98.     o_invert,    OPNUL,  "INVERT",    /* invert top value */
  99.     o_int,        OPNUL,  "INT",        /* take integer part */
  100.     o_frac,        OPNUL,  "FRAC",        /* take fraction part */
  101.     o_numerator,    OPNUL,  "NUMERATOR",    /* take numerator */
  102.     o_denominator,    OPNUL,  "DENOMINATOR",    /* take denominator */
  103.     o_duplicate,    OPNUL,  "DUPLICATE",    /* duplicate top value */
  104.     o_pop,        OPNUL,  "POP",        /* pop top value */
  105.     o_return,    OPRET,  "RETURN",    /* return value of function */
  106.     o_jumpeq,    OPJMP,  "JUMPEQ",    /* jump if value zero */
  107.     o_jumpne,    OPJMP,  "JUMPNE",    /* jump if value nonzero */
  108.     o_jump,        OPJMP,  "JUMP",        /* jump unconditionally */
  109.     o_usercall,    OPTWO,  "USERCALL",    /* call a user function */
  110.     o_getvalue,    OPNUL,  "GETVALUE",    /* convert address to value */
  111.     o_eq,        OPNUL,  "EQ",        /* test elements for equality */
  112.     o_ne,        OPNUL,  "NE",        /* test elements for inequality */
  113.     o_le,        OPNUL,  "LE",        /* test elements for <= */
  114.     o_ge,        OPNUL,  "GE",        /* test elements for >= */
  115.     o_lt,        OPNUL,  "LT",        /* test elements for < */
  116.     o_gt,        OPNUL,  "GT",        /* test elements for > */
  117.     o_preinc,    OPNUL,  "PREINC",    /* add one to variable (++x) */
  118.     o_predec,    OPNUL,  "PREDEC",    /* subtract one from variable (--x) */
  119.     o_postinc,    OPNUL,  "POSTINC",    /* add one to variable (x++) */
  120.     o_postdec,    OPNUL,  "POSTDEC",    /* subtract one from variable (x--) */
  121.     o_debug,    OPONE,  "DEBUG",    /* debugging point */
  122.     o_print,    OPONE,  "PRINT",    /* print value */
  123.     o_assignpop,    OPNUL,  "ASSIGNPOP",    /* assign to variable and pop it */
  124.     o_zero,        OPNUL,  "ZERO",        /* put zero on the stack */
  125.     o_one,        OPNUL,  "ONE",        /* put one on the stack */
  126.     o_printeol,    OPNUL,  "PRINTEOL",    /* print end of line */
  127.     o_printspace,    OPNUL,  "PRINTSPACE",    /* print a space */
  128.     o_printstring,    OPSTR,  "PRINTSTR",    /* print constant string */
  129.     o_dupvalue,    OPNUL,  "DUPVALUE",    /* duplicate value of top value */
  130.     o_oldvalue,    OPNUL,  "OLDVALUE",    /* old value from previous calc */
  131.     o_quo,        OPNUL,  "QUO",        /* integer quotient of top values */
  132.     o_power,    OPNUL,  "POWER",    /* value raised to a power */
  133.     o_quit,        OPSTR,  "QUIT",        /* quit program */
  134.     o_call,        OPTWO,  "CALL",        /* call built-in routine */
  135.     o_getepsilon,    OPNUL,  "GETEPSILON",    /* get allowed error for calculations */
  136.     o_and,        OPNUL,  "AND",        /* arithmetic and or top two values */
  137.     o_or,        OPNUL,  "OR",        /* arithmetic or of top two values */
  138.     o_not,        OPNUL,  "NOT",        /* logical not or top value */
  139.     o_abs,        OPNUL,  "ABS",        /* absolute value of top value */
  140.     o_sgn,        OPNUL,  "SGN",        /* sign of number */
  141.     o_isint,    OPNUL,  "ISINT",    /* whether number is an integer */
  142.     o_condorjump,    OPJMP,  "CONDORJUMP",    /* conditional or jump */
  143.     o_condandjump,    OPJMP,  "CONDANDJUMP",    /* conditional and jump */
  144.     o_square,    OPNUL,  "SQUARE",    /* square top value */
  145.     o_string,    OPSTR,  "STRING",    /* string constant value */
  146.     o_isnum,    OPNUL,  "ISNUM",    /* whether value is a number */
  147.     o_undef,    OPNUL,  "UNDEF",    /* load undefined value on stack */
  148.     o_isnull,    OPNUL,  "ISNULL",    /* whether value is the null value */
  149.     o_argvalue,    OPARG,  "ARGVALUE",    /* load value of arg (parameter) n */
  150.     o_matcreate,    OPONE,  "MATCREATE",    /* create matrix */
  151.     o_ismat,    OPNUL,  "ISMAT",    /* whether value is a matrix */
  152.     o_isstr,    OPNUL,  "ISSTR",    /* whether value is a string */
  153.     o_getconfig,    OPNUL,  "GETCONFIG",    /* get value of configuration parameter */
  154.     o_leftshift,    OPNUL,  "LEFTSHIFT",    /* left shift of integer */
  155.     o_rightshift,    OPNUL,  "RIGHTSHIFT",    /* right shift of integer */
  156.     o_casejump,    OPJMP,  "CASEJUMP",    /* test case and jump if not matched */
  157.     o_isodd,    OPNUL,  "ISODD",    /* whether value is odd integer */
  158.     o_iseven,    OPNUL,  "ISEVEN",    /* whether value is even integer */
  159.     o_fiaddr,    OPNUL,  "FIADDR",    /* 'fast index' matrix address */
  160.     o_fivalue,    OPNUL,  "FIVALUE",    /* 'fast index' matrix value */
  161.     o_isreal,    OPNUL,  "ISREAL",    /* whether value is real number */
  162.     o_imaginary,    OPONE,  "IMAGINARY",    /* constant imaginary numeric value */
  163.     o_re,        OPNUL,  "RE",        /* real part of complex number */
  164.     o_im,        OPNUL,  "IM",        /* imaginary part of complex number */
  165.     o_conjugate,    OPNUL,  "CONJUGATE",    /* complex conjugate */
  166.     o_objcreate,    OPONE,  "OBJCREATE",    /* create object */
  167.     o_isobj,    OPNUL,  "ISOBJ",    /* whether value is an object */
  168.     o_norm,        OPNUL,  "NORM",        /* norm of value (square of abs) */
  169.     o_elemaddr,    OPONE,  "ELEMADDR",    /* address of element of object */
  170.     o_elemvalue,    OPONE,  "ELEMVALUE",    /* value of element of object */
  171.     o_istype,    OPNUL,  "ISTYPE",    /* whether types are the same */
  172.     o_scale,    OPNUL,  "SCALE",    /* scale value by a power of two */
  173.     o_islist,    OPNUL,    "ISLIST",    /* whether value is a list */
  174.     o_swap,        OPNUL,    "SWAP",        /* swap values of two variables */
  175.     o_issimple,    OPNUL,    "ISSIMPLE",    /* whether value is simple type */
  176.     o_cmp,        OPNUL,    "CMP",        /* compare values returning -1, 0, 1 */
  177.     o_quomod,    OPNUL,    "QUOMOD",    /* calculate quotient and remainder */
  178.     o_setconfig,    OPNUL,    "SETCONFIG",    /* set configuration parameter */
  179.     o_setepsilon,    OPNUL,  "SETEPSILON",    /* set allowed error for calculations */
  180.     o_isfile,    OPNUL,  "ISFILE",    /* whether value is a file */
  181.     o_isassoc,    OPNUL,  "ISASSOC",    /* whether value is an association */
  182.     o_nop,        OPSTI,  "INITSTATIC",    /* once only code for static init */
  183.     o_eleminit,    OPONE,    "ELEMINIT"    /* assign element of matrix or object */
  184. };
  185.  
  186.  
  187.  
  188. /*
  189.  * Initialize the stack.
  190.  */
  191. void
  192. initstack()
  193. {
  194.     int i;
  195.  
  196.     /* on first init, setup the stack array */
  197.     if (stack == NULL) {
  198.         for (i=0; i < sizeof(stackarray)/sizeof(stackarray[0]); ++i) {
  199.             stackarray[i].v_type = V_NULL;
  200.             stackarray[i].v_subtype = V_NOSUBTYPE;
  201.         }
  202.         stack = stackarray;
  203.  
  204.     /* on subsequent inits, free the old stack */
  205.     } else {
  206.         while (stack > stackarray) {
  207.             freevalue(stack--);
  208.         }
  209.     }
  210. }
  211.  
  212.  
  213. /*
  214.  * Compute the result of a function by interpreting opcodes.
  215.  * Arguments have just been pushed onto the evaluation stack.
  216.  */
  217. void
  218. calculate(fp, argcount)
  219.     register FUNC *fp;        /* function to calculate */
  220.     int argcount;            /* number of arguments called with */
  221. {
  222.     register unsigned long pc;    /* current pc inside function */
  223.     register struct opcode *op;    /* current opcode pointer */
  224.     register VALUE *locals;        /* pointer to local variables */
  225.     long oldline;            /* old value of line counter */
  226.     unsigned int opnum;        /* current opcode number */
  227.     int origargcount;        /* original number of arguments */
  228.     int i;                /* loop counter */
  229.     BOOL dojump;            /* TRUE if jump is to occur */
  230.     char *oldname;            /* old function name being executed */
  231.     VALUE *beginstack;        /* beginning of stack frame */
  232.     VALUE *args;            /* pointer to function arguments */
  233.     VALUE retval;            /* function return value */
  234.     VALUE localtable[QUICKLOCALS];    /* some local variables */
  235.  
  236.     oldname = funcname;
  237.     oldline = funcline;
  238.     funcname = fp->f_name;
  239.     funcline = 0;
  240.     origargcount = argcount;
  241.     while (argcount < fp->f_paramcount) {
  242.         stack++;
  243.         stack->v_type = V_NULL;
  244.         argcount++;
  245.     }
  246.     locals = localtable;
  247.     if (fp->f_localcount > QUICKLOCALS) {
  248.         locals = (VALUE *) malloc(sizeof(VALUE) * fp->f_localcount);
  249.         if (locals == NULL)
  250.             math_error("No memory for local variables");
  251.     }
  252.     for (i = 0; i < fp->f_localcount; i++) {
  253.         locals[i].v_num = qlink(&_qzero_);
  254.         locals[i].v_type = V_NUM;
  255.         locals[i].v_subtype = V_NOSUBTYPE;
  256.     }
  257.     pc = 0;
  258.     beginstack = stack;
  259.     args = beginstack - (argcount - 1);
  260.     for (;;) {
  261.         if (abortlevel >= ABORT_OPCODE)
  262.             math_error("Calculation aborted in opcode");
  263.         if (pc >= fp->f_opcodecount)
  264.             math_error("Function pc out of range");
  265.         if (stack > &stackarray[MAXSTACK-3])
  266.             math_error("Evaluation stack depth exceeded");
  267.         opnum = fp->f_opcodes[pc];
  268.         if (opnum > MAX_OPCODE)
  269.             math_error("Function opcode out of range");
  270.         op = &opcodes[opnum];
  271.         if (traceflags & TRACE_OPCODES) {
  272.             printf("%8s, pc %4ld:  ", fp->f_name, pc);
  273.             (void)dumpop(&fp->f_opcodes[pc]);
  274.         }
  275.         /*
  276.          * Now call the opcode routine appropriately.
  277.          */
  278.         pc++;
  279.         switch (op->o_type) {
  280.         case OPNUL:    /* no extra arguments */
  281.             (*op->o_func)(fp);
  282.             break;
  283.  
  284.         case OPONE:    /* one extra integer argument */
  285.             (*op->o_func)(fp, fp->f_opcodes[pc++]);
  286.             break;
  287.  
  288.         case OPTWO:    /* two extra integer arguments */
  289.             (*op->o_func)(fp, fp->f_opcodes[pc],
  290.                 fp->f_opcodes[pc+1]);
  291.             pc += 2;
  292.             break;
  293.  
  294.         case OPJMP:    /* jump opcodes (one extra pointer arg) */
  295.             dojump = FALSE;
  296.             (*op->o_func)(fp, &dojump);
  297.             if (dojump)
  298.                 pc = fp->f_opcodes[pc];
  299.             else
  300.                 pc++;
  301.             break;
  302.  
  303.         case OPGLB:    /* global symbol reference (pointer arg) */
  304.         case OPSTR:    /* string constant address */
  305.             (*op->o_func)(fp, *((char **) &fp->f_opcodes[pc]));
  306.             pc += PTR_SIZE;
  307.             break;
  308.  
  309.         case OPLOC:    /* local variable reference */
  310.             (*op->o_func)(fp, locals, fp->f_opcodes[pc++]);
  311.             break;
  312.  
  313.         case OPPAR:    /* parameter variable reference */
  314.             (*op->o_func)(fp, argcount, args, fp->f_opcodes[pc++]);
  315.             break;
  316.  
  317.         case OPARG:    /* parameter variable reference */
  318.             (*op->o_func)(fp, origargcount, args);
  319.             break;
  320.  
  321.         case OPRET:    /* return from function */
  322.             if (stack->v_type == V_ADDR)
  323.                 copyvalue(stack->v_addr, stack);
  324.             for (i = 0; i < fp->f_localcount; i++)
  325.                 freevalue(&locals[i]);
  326.             if (locals != localtable)
  327.                 free(locals);
  328.             if (stack != &beginstack[1])
  329.                 math_error("Misaligned stack");
  330.             if (argcount <= 0) {
  331.                 funcname = oldname;
  332.                 funcline = oldline;
  333.                 return;
  334.             }
  335.             retval = *stack--;
  336.             while (--argcount >= 0)
  337.                 freevalue(stack--);
  338.             *++stack = retval;
  339.             funcname = oldname;
  340.             funcline = oldline;
  341.             return;
  342.  
  343.         case OPSTI:    /* static initialization code */
  344.             fp->f_opcodes[pc++ - 1] = OP_JUMP;
  345.             break;
  346.         
  347.         default:
  348.             math_error("Unknown opcode type");
  349.         }
  350.     }
  351. }
  352.  
  353.  
  354. /*
  355.  * Dump an opcode at a particular address.
  356.  * Returns the size of the opcode so that it can easily be skipped over.
  357.  */
  358. int
  359. dumpop(pc)
  360.     long *pc;        /* location of the opcode */
  361. {
  362.     unsigned long op;    /* opcode number */
  363.  
  364.     op = *pc++;
  365.     if (op <= MAX_OPCODE)
  366.         printf("%s", opcodes[op].o_name);
  367.     else
  368.         printf("OP%ld", op);
  369.     switch (op) {
  370.         case OP_LOCALADDR: case OP_LOCALVALUE:
  371.             printf(" %s\n", localname(*pc));
  372.             return 2;
  373.         case OP_GLOBALADDR: case OP_GLOBALVALUE:
  374.             printf(" %s\n", globalname(*((GLOBAL **) pc)));
  375.             return (1 + PTR_SIZE);
  376.         case OP_PARAMADDR: case OP_PARAMVALUE:
  377.             printf(" %s\n", paramname(*pc));
  378.             return 2;
  379.         case OP_PRINTSTRING: case OP_STRING:
  380.             printf(" \"%s\"\n", *((char **) pc));
  381.             return (1 + PTR_SIZE);
  382.         case OP_QUIT:
  383.             if (*(char **) pc)
  384.                 printf(" \"%s\"\n", *((char **) pc));
  385.             else
  386.                 printf("\n");
  387.             return (1 + PTR_SIZE);
  388.         case OP_INDEXADDR:
  389.             printf(" %ld %ld\n", pc[0], pc[1]);
  390.             return 3;
  391.         case OP_PRINT: case OP_JUMPEQ: case OP_JUMPNE: case OP_JUMP:
  392.         case OP_CONDORJUMP: case OP_CONDANDJUMP: case OP_CASEJUMP:
  393.         case OP_INITSTATIC: case OP_MATCREATE: case OP_OBJCREATE:
  394.             printf(" %ld\n", *pc);
  395.             return 2;
  396.         case OP_NUMBER: case OP_IMAGINARY:
  397.             qprintf(" %r\n", constvalue(*pc));
  398.             return 2;
  399.         case OP_DEBUG:
  400.             printf(" line %ld\n", *pc);
  401.             return 2;
  402.         case OP_CALL:
  403.             printf(" %s with %ld args\n", builtinname(pc[0]), pc[1]);
  404.             return 3;
  405.         case OP_USERCALL:
  406.             printf(" %s with %ld args\n", namefunc(pc[0]), pc[1]);
  407.             return 3;
  408.         default:
  409.             printf("\n");
  410.             return 1;
  411.     }
  412. }
  413.  
  414.  
  415. /*
  416.  * The various opcodes
  417.  */
  418.  
  419. static void
  420. o_nop()
  421. {
  422. }
  423.  
  424.  
  425. static void
  426. o_localaddr(fp, locals, index)
  427.     FUNC *fp;
  428.     VALUE *locals;
  429.     long index;
  430. {
  431.     if ((unsigned long)index >= fp->f_localcount)
  432.         math_error("Bad local variable index");
  433.     locals += index;
  434.     stack++;
  435.     stack->v_addr = locals;
  436.     stack->v_type = V_ADDR;
  437. }
  438.  
  439.  
  440. /*ARGSUSED*/
  441. static void
  442. o_globaladdr(fp, sp)
  443.     FUNC *fp;
  444.     GLOBAL *sp;
  445. {
  446.     if (sp == NULL)
  447.         math_error("Global variable \"%s\" not initialized", sp->g_name);
  448.     stack++;
  449.     stack->v_addr = &sp->g_value;
  450.     stack->v_type = V_ADDR;
  451. }
  452.  
  453.  
  454. /*ARGSUSED*/
  455. static void
  456. o_paramaddr(fp, argcount, args, index)
  457.     FUNC *fp;
  458.     int argcount;
  459.     VALUE *args;
  460.     long index;
  461. {
  462.     if ((unsigned long)index >= argcount)
  463.         math_error("Bad parameter index");
  464.     args += index;
  465.     stack++;
  466.     if (args->v_type == V_ADDR)
  467.         stack->v_addr = args->v_addr;
  468.     else
  469.         stack->v_addr = args;
  470.     stack->v_type = V_ADDR;
  471. }
  472.  
  473.  
  474. static void
  475. o_localvalue(fp, locals, index)
  476.     FUNC *fp;
  477.     VALUE *locals;
  478.     long index;
  479. {
  480.     if ((unsigned long)index >= fp->f_localcount)
  481.         math_error("Bad local variable index");
  482.     locals += index;
  483.     copyvalue(locals, ++stack);
  484. }
  485.  
  486.  
  487. /*ARGSUSED*/
  488. static void
  489. o_globalvalue(fp, sp)
  490.     FUNC *fp;
  491.     GLOBAL *sp;        /* global symbol */
  492. {
  493.     if (sp == NULL)
  494.         math_error("Global variable not defined");
  495.     copyvalue(&sp->g_value, ++stack);
  496. }
  497.  
  498.  
  499. /*ARGSUSED*/
  500. static void
  501. o_paramvalue(fp, argcount, args, index)
  502.     FUNC *fp;
  503.     int argcount;
  504.     VALUE *args;
  505.     long index;
  506. {
  507.     if ((unsigned long)index >= argcount)
  508.         math_error("Bad paramaeter index");
  509.     args += index;
  510.     if (args->v_type == V_ADDR)
  511.         args = args->v_addr;
  512.     copyvalue(args, ++stack);
  513. }
  514.  
  515.  
  516. static void
  517. o_argvalue(fp, argcount, args)
  518.     FUNC *fp;
  519.     int argcount;
  520.     VALUE *args;
  521. {
  522.     VALUE *vp;
  523.     long index;
  524.  
  525.     vp = stack;
  526.     if (vp->v_type == V_ADDR)
  527.         vp = vp->v_addr;
  528.     if ((vp->v_type != V_NUM) || qisneg(vp->v_num) ||
  529.         qisfrac(vp->v_num))
  530.             math_error("Illegal argument for arg function");
  531.     if (qiszero(vp->v_num)) {
  532.         if (stack->v_type == V_NUM)
  533.             qfree(stack->v_num);
  534.         stack->v_num = itoq((long) argcount);
  535.         stack->v_type = V_NUM;
  536.         return;
  537.     }
  538.     index = qtoi(vp->v_num) - 1;
  539.     if (stack->v_type == V_NUM)
  540.         qfree(stack->v_num);
  541.     stack--;
  542.     (void) o_paramvalue(fp, argcount, args, index);
  543. }
  544.  
  545.  
  546. /*ARGSUSED*/
  547. static void
  548. o_number(fp, arg)
  549.     FUNC *fp;
  550.     long arg;
  551. {
  552.     NUMBER *q;
  553.  
  554.     q = constvalue(arg);
  555.     if (q == NULL)
  556.         math_error("Numeric constant value not found");
  557.     stack++;
  558.     stack->v_num = qlink(q);
  559.     stack->v_type = V_NUM;
  560. }
  561.  
  562.  
  563. /*ARGSUSED*/
  564. static void
  565. o_imaginary(fp, arg)
  566.     FUNC *fp;
  567.     long arg;
  568. {
  569.     NUMBER *q;
  570.     COMPLEX *c;
  571.  
  572.     q = constvalue(arg);
  573.     if (q == NULL)
  574.         math_error("Numeric constant value not found");
  575.     stack++;
  576.     if (qiszero(q)) {
  577.         stack->v_num = qlink(q);
  578.         stack->v_type = V_NUM;
  579.         return;
  580.     }
  581.     c = comalloc();
  582.     c->real = qlink(&_qzero_);
  583.     c->imag = qlink(q);
  584.     stack->v_com = c;
  585.     stack->v_type = V_COM;
  586. }
  587.  
  588.  
  589. /*ARGSUSED*/
  590. static void
  591. o_string(fp, cp)
  592.     FUNC *fp;
  593.     char *cp;
  594. {
  595.     stack++;
  596.     stack->v_str = cp;
  597.     stack->v_type = V_STR;
  598.     stack->v_subtype = V_STRLITERAL;
  599. }
  600.  
  601.  
  602. static void
  603. o_undef()
  604. {
  605.     stack++;
  606.     stack->v_type = V_NULL;
  607. }
  608.  
  609.  
  610. /*ARGSUSED*/
  611. static void
  612. o_matcreate(fp, dim)
  613.     FUNC *fp;
  614.     long dim;
  615. {
  616.     register MATRIX *mp;    /* matrix being defined */
  617.     NUMBER *num1;        /* first number from stack */
  618.     NUMBER *num2;        /* second number from stack */
  619.     VALUE *vp;        /* value being defined */
  620.     VALUE *v1, *v2;
  621.     long min[MAXDIM];    /* minimum range */
  622.     long max[MAXDIM];    /* maximum range */
  623.     long i;            /* index */
  624.     long tmp;        /* temporary */
  625.     long size;        /* size of matrix */
  626.  
  627.     if ((dim <= 0) || (dim > MAXDIM))
  628.         math_error("Bad dimension %ld for matrix", dim);
  629.     if (stack[-2*dim].v_type != V_ADDR)
  630.         math_error("Attempting to init matrix for non-address");
  631.     size = 1;
  632.     for (i = dim - 1; i >= 0; i--) {
  633.         v1 = &stack[-1];
  634.         v2 = &stack[0];
  635.         if (v1->v_type == V_ADDR)
  636.             v1 = v1->v_addr;
  637.         if (v2->v_type == V_ADDR)
  638.             v2 = v2->v_addr;
  639.         if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM))
  640.             math_error("Non-numeric bounds for matrix");
  641.         num1 = v1->v_num;
  642.         num2 = v2->v_num;
  643.         if (qisfrac(num1) || qisfrac(num2))
  644.             math_error("Non-integral bounds for matrix");
  645.         if (zge31b(num1->num) || zge31b(num2->num))
  646.             math_error("Very large bounds for matrix");
  647.         min[i] = qtoi(num1);
  648.         max[i] = qtoi(num2);
  649.         if (min[i] > max[i]) {
  650.             tmp = min[i];
  651.             min[i] = max[i];
  652.             max[i] = tmp;
  653.         }
  654.         size *= (max[i] - min[i] + 1);
  655.         if (size > 10000000)
  656.             math_error("Very large size for matrix");
  657.         freevalue(stack--);
  658.         freevalue(stack--);
  659.     }
  660.     mp = matalloc(size);
  661.     mp->m_dim = dim;
  662.     for (i = 0; i < dim; i++) {
  663.         mp->m_min[i] = min[i];
  664.         mp->m_max[i] = max[i];
  665.     }
  666.     vp = mp->m_table;
  667.     for (i = 0; i < size; i++) {
  668.         vp->v_type = V_NUM;
  669.         vp->v_num = qlink(&_qzero_);
  670.         vp++;
  671.     }
  672.     vp = stack[0].v_addr;
  673.     vp->v_type = V_MAT;
  674.     vp->v_mat = mp;
  675. }
  676.  
  677.  
  678. /*ARGSUSED*/
  679. static void
  680. o_eleminit(fp, index)
  681.     FUNC *fp;
  682.     long index;
  683. {
  684.     VALUE *vp;
  685.     static VALUE *oldvp;
  686.     MATRIX *mp;
  687.     OBJECT *op;
  688.  
  689.     vp = &stack[-1];
  690.     if (vp->v_type == V_ADDR)
  691.         vp = vp->v_addr;
  692.     switch (vp->v_type) {
  693.         case V_MAT:
  694.             mp = vp->v_mat;
  695.             if ((index < 0) || (index >= mp->m_size))
  696.                 math_error("Too many initializer values");
  697.             oldvp = &mp->m_table[index];
  698.             break;
  699.         case V_OBJ:
  700.             op = vp->v_obj;
  701.             if ((index < 0) || (index >= op->o_actions->count))
  702.                 math_error("Too many initializer values");
  703.             oldvp = &op->o_table[index];
  704.             break;
  705.         default:
  706.             math_error("Attempt to initialize non matrix or object");
  707.     }
  708.     vp = stack;
  709.     if (vp->v_type == V_ADDR)
  710.         vp = vp->v_addr;
  711.     freevalue(oldvp);
  712.     copyvalue(vp, oldvp);
  713.     stack--;
  714. }
  715.  
  716.  
  717. /*ARGSUSED*/
  718. static void
  719. o_indexaddr(fp, dim, writeflag)
  720.     FUNC *fp;
  721.     long dim;        /* dimension of matrix */
  722.     long writeflag;        /* nonzero if element will be written */
  723. {
  724.     int i;
  725.     BOOL flag;
  726.     VALUE *val;
  727.     VALUE *vp;
  728.     VALUE indices[MAXDIM];    /* index values */
  729.  
  730.     flag = (writeflag != 0);
  731.     if ((dim <= 0) || (dim > MAXDIM))
  732.         math_error("Too many dimensions for indexing");
  733.     val = &stack[-dim];
  734.     if (val->v_type != V_ADDR)
  735.         math_error("Non-pointer for index operation");
  736.     val = val->v_addr;
  737.     vp = &stack[-dim + 1];
  738.     for (i = 0; i < dim; i++) {
  739.         if (vp->v_type == V_ADDR)
  740.             indices[i] = vp->v_addr[0];
  741.         else
  742.             indices[i] = vp[0];
  743.         vp++;
  744.     }
  745.     switch (val->v_type) {
  746.         case V_MAT:
  747.             vp = matindex(val->v_mat, flag, dim, indices);
  748.             break;
  749.         case V_ASSOC:
  750.             vp = associndex(val->v_assoc, flag, dim, indices);
  751.             break;
  752.         default:
  753.             math_error("Illegal value for indexing");
  754.     }
  755.     while (dim-- > 0)
  756.         freevalue(stack--);
  757.     stack->v_type = V_ADDR;
  758.     stack->v_addr = vp;
  759. }
  760.  
  761.  
  762. /*ARGSUSED*/
  763. static void
  764. o_elemaddr(fp, index)
  765.     FUNC *fp;
  766.     long index;
  767. {
  768.     if (stack->v_type != V_ADDR)
  769.         math_error("Non-pointer for element reference");
  770.     if (stack->v_addr->v_type != V_OBJ)
  771.         math_error("Referencing element of non-object");
  772.     index = objoffset(stack->v_addr->v_obj, index);
  773.     if (index < 0)
  774.         math_error("Element does not exist for object");
  775.     stack->v_addr = &stack->v_addr->v_obj->o_table[index];
  776. }
  777.  
  778.  
  779. static void
  780. o_elemvalue(fp, index)
  781.     FUNC *fp;
  782.     long index;
  783. {
  784.     if (stack->v_type != V_OBJ) {
  785.         (void) o_elemaddr(fp, index);
  786.         (void) o_getvalue();
  787.         return;
  788.     }
  789.     index = objoffset(stack->v_obj, index);
  790.     if (index < 0)
  791.         math_error("Element does not exist for object");
  792.     copyvalue(&stack->v_obj->o_table[index], stack);
  793. }
  794.  
  795.  
  796. /*ARGSUSED*/
  797. static void
  798. o_objcreate(fp, arg)
  799.     FUNC *fp;
  800.     long arg;
  801. {
  802.     OBJECT *op;        /* object being created */
  803.     VALUE *vp;        /* value being defined */
  804.  
  805.     if (stack->v_type != V_ADDR)
  806.         math_error("Attempting to init object for non-address");
  807.     op = objalloc(arg);
  808.     vp = stack->v_addr;
  809.     vp->v_type = V_OBJ;
  810.     vp->v_obj = op;
  811. }
  812.  
  813.  
  814. static void
  815. o_assign()
  816. {
  817.     VALUE *var;        /* variable value */
  818.     VALUE *vp;
  819.  
  820.     var = &stack[-1];
  821.     if (var->v_type != V_ADDR)
  822.         math_error("Assignment into non-variable");
  823.     var = var->v_addr;
  824.     stack[-1] = stack[0];
  825.     stack--;
  826.     vp = stack;
  827.     if (vp->v_type == V_ADDR) {
  828.         vp = vp->v_addr;
  829.         if (vp == var)
  830.             return;
  831.     }
  832.     freevalue(var);
  833.     copyvalue(vp, var);
  834. }
  835.  
  836.  
  837. static void
  838. o_assignpop()
  839. {
  840.     VALUE *var;        /* variable value */
  841.     VALUE *vp;
  842.  
  843.     var = &stack[-1];
  844.     if (var->v_type != V_ADDR)
  845.         math_error("Assignment into non-variable");
  846.     var = var->v_addr;
  847.     vp = &stack[0];
  848.     if ((vp->v_type == V_ADDR) && (vp->v_addr == var)) {
  849.         stack -= 2;
  850.         return;
  851.     }
  852.     freevalue(var);
  853.     if (vp->v_type == V_ADDR)
  854.         copyvalue(vp->v_addr, var);
  855.     else
  856.         *var = *vp;
  857.     stack -= 2;
  858. }
  859.  
  860.  
  861. static void
  862. o_swap()
  863. {
  864.     VALUE *v1, *v2;        /* variables to be swapped */
  865.     VALUE tmp;
  866.  
  867.     v1 = &stack[-1];
  868.     v2 = &stack[0];
  869.     if ((v1->v_type != V_ADDR) || (v2->v_type != V_ADDR))
  870.         math_error("Swapping non-variables");
  871.     tmp = v1->v_addr[0];
  872.     v1->v_addr[0] = v2->v_addr[0];
  873.     v2->v_addr[0] = tmp;
  874.     stack--;
  875.     stack->v_type = V_NULL;
  876. }
  877.  
  878.  
  879. static void
  880. o_add()
  881. {
  882.     VALUE *v1, *v2;
  883.     NUMBER *q;
  884.     VALUE tmp;
  885.  
  886.     v1 = &stack[-1];
  887.     v2 = &stack[0];
  888.     if (v1->v_type == V_ADDR)
  889.         v1 = v1->v_addr;
  890.     if (v2->v_type == V_ADDR)
  891.         v2 = v2->v_addr;
  892.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
  893.         addvalue(v1, v2, &tmp);
  894.         freevalue(stack--);
  895.         freevalue(stack);
  896.         *stack = tmp;
  897.         return;
  898.     }
  899.     q = qadd(v1->v_num, v2->v_num);
  900.     if (stack->v_type == V_NUM)
  901.         qfree(stack->v_num);
  902.     stack--;
  903.     if (stack->v_type == V_NUM)
  904.         qfree(stack->v_num);
  905.     stack->v_num = q;
  906.     stack->v_type = V_NUM;
  907. }
  908.  
  909.  
  910. static void
  911. o_sub()
  912. {
  913.     VALUE *v1, *v2;
  914.     NUMBER *q;
  915.     VALUE tmp;
  916.  
  917.     v1 = &stack[-1];
  918.     v2 = &stack[0];
  919.     if (v1->v_type == V_ADDR)
  920.         v1 = v1->v_addr;
  921.     if (v2->v_type == V_ADDR)
  922.         v2 = v2->v_addr;
  923.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
  924.         subvalue(v1, v2, &tmp);
  925.         freevalue(stack--);
  926.         freevalue(stack);
  927.         *stack = tmp;
  928.         return;
  929.     }
  930.     q = qsub(v1->v_num, v2->v_num);
  931.     if (stack->v_type == V_NUM)
  932.         qfree(stack->v_num);
  933.     stack--;
  934.     if (stack->v_type == V_NUM)
  935.         qfree(stack->v_num);
  936.     stack->v_num = q;
  937.     stack->v_type = V_NUM;
  938. }
  939.  
  940.  
  941. static void
  942. o_mul()
  943. {
  944.     VALUE *v1, *v2;
  945.     NUMBER *q;
  946.     VALUE tmp;
  947.  
  948.     v1 = &stack[-1];
  949.     v2 = &stack[0];
  950.     if (v1->v_type == V_ADDR)
  951.         v1 = v1->v_addr;
  952.     if (v2->v_type == V_ADDR)
  953.         v2 = v2->v_addr;
  954.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
  955.         mulvalue(v1, v2, &tmp);
  956.         freevalue(stack--);
  957.         freevalue(stack);
  958.         *stack = tmp;
  959.         return;
  960.     }
  961.     q = qmul(v1->v_num, v2->v_num);
  962.     if (stack->v_type == V_NUM)
  963.         qfree(stack->v_num);
  964.     stack--;
  965.     if (stack->v_type == V_NUM)
  966.         qfree(stack->v_num);
  967.     stack->v_num = q;
  968.     stack->v_type = V_NUM;
  969. }
  970.  
  971.  
  972. static void
  973. o_power()
  974. {
  975.     VALUE *v1, *v2;
  976.     VALUE tmp;
  977.  
  978.     v1 = &stack[-1];
  979.     v2 = &stack[0];
  980.     if (v1->v_type == V_ADDR)
  981.         v1 = v1->v_addr;
  982.     if (v2->v_type == V_ADDR)
  983.         v2 = v2->v_addr;
  984.     powivalue(v1, v2, &tmp);
  985.     freevalue(stack--);
  986.     freevalue(stack);
  987.     *stack = tmp;
  988. }
  989.  
  990.  
  991. static void
  992. o_div()
  993. {
  994.     VALUE *v1, *v2;
  995.     NUMBER *q;
  996.     VALUE tmp;
  997.  
  998.     v1 = &stack[-1];
  999.     v2 = &stack[0];
  1000.     if (v1->v_type == V_ADDR)
  1001.         v1 = v1->v_addr;
  1002.     if (v2->v_type == V_ADDR)
  1003.         v2 = v2->v_addr;
  1004.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
  1005.         divvalue(v1, v2, &tmp);
  1006.         freevalue(stack--);
  1007.         freevalue(stack);
  1008.         *stack = tmp;
  1009.         return;
  1010.     }
  1011.     q = qdiv(v1->v_num, v2->v_num);
  1012.     if (stack->v_type == V_NUM)
  1013.         qfree(stack->v_num);
  1014.     stack--;
  1015.     if (stack->v_type == V_NUM)
  1016.         qfree(stack->v_num);
  1017.     stack->v_num = q;
  1018.     stack->v_type = V_NUM;
  1019. }
  1020.  
  1021.  
  1022. static void
  1023. o_quo()
  1024. {
  1025.     VALUE *v1, *v2;
  1026.     NUMBER *q;
  1027.     VALUE tmp;
  1028.  
  1029.     v1 = &stack[-1];
  1030.     v2 = &stack[0];
  1031.     if (v1->v_type == V_ADDR)
  1032.         v1 = v1->v_addr;
  1033.     if (v2->v_type == V_ADDR)
  1034.         v2 = v2->v_addr;
  1035.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
  1036.         quovalue(v1, v2, &tmp);
  1037.         freevalue(stack--);
  1038.         freevalue(stack);
  1039.         *stack = tmp;
  1040.         return;
  1041.     }
  1042.     q = qquo(v1->v_num, v2->v_num);
  1043.     if (stack->v_type == V_NUM)
  1044.         qfree(stack->v_num);
  1045.     stack--;
  1046.     if (stack->v_type == V_NUM)
  1047.         qfree(stack->v_num);
  1048.     stack->v_num = q;
  1049.     stack->v_type = V_NUM;
  1050. }
  1051.  
  1052.  
  1053. static void
  1054. o_mod()
  1055. {
  1056.     VALUE *v1, *v2;
  1057.     NUMBER *q;
  1058.     VALUE tmp;
  1059.  
  1060.     v1 = &stack[-1];
  1061.     v2 = &stack[0];
  1062.     if (v1->v_type == V_ADDR)
  1063.         v1 = v1->v_addr;
  1064.     if (v2->v_type == V_ADDR)
  1065.         v2 = v2->v_addr;
  1066.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
  1067.         modvalue(v1, v2, &tmp);
  1068.         freevalue(stack--);
  1069.         freevalue(stack);
  1070.         *stack = tmp;
  1071.         return;
  1072.     }
  1073.     q = qmod(v1->v_num, v2->v_num);
  1074.     if (stack->v_type == V_NUM)
  1075.         qfree(stack->v_num);
  1076.     stack--;
  1077.     if (stack->v_type == V_NUM)
  1078.         qfree(stack->v_num);
  1079.     stack->v_num = q;
  1080.     stack->v_type = V_NUM;
  1081. }
  1082.  
  1083.  
  1084. static void
  1085. o_quomod()
  1086. {
  1087.     VALUE *v1, *v2, *v3, *v4;
  1088.     VALUE valquo, valmod;
  1089.     BOOL res;
  1090.  
  1091.     v1 = &stack[-3];
  1092.     v2 = &stack[-2];
  1093.     v3 = &stack[-1];
  1094.     v4 = &stack[0];
  1095.     if (v1->v_type == V_ADDR)
  1096.         v1 = v1->v_addr;
  1097.     if (v2->v_type == V_ADDR)
  1098.         v2 = v2->v_addr;
  1099.     if ((v3->v_type != V_ADDR) || (v4->v_type != V_ADDR))
  1100.         math_error("Non-variable for quomod");
  1101.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM))
  1102.         math_error("Non-reals for quomod");
  1103.     v3 = v3->v_addr;
  1104.     v4 = v4->v_addr;
  1105.     valquo.v_type = V_NUM;
  1106.     valmod.v_type = V_NUM;
  1107.     res = qquomod(v1->v_num, v2->v_num, &valquo.v_num, &valmod.v_num);
  1108.     freevalue(stack--);
  1109.     freevalue(stack--);
  1110.     stack--;
  1111.     stack->v_num = (res ? qlink(&_qone_) : qlink(&_qzero_));
  1112.     stack->v_type = V_NUM;
  1113.     freevalue(v3);
  1114.     freevalue(v4);
  1115.     *v3 = valquo;
  1116.     *v4 = valmod;
  1117. }
  1118.  
  1119.  
  1120. static void
  1121. o_and()
  1122. {
  1123.     VALUE *v1, *v2;
  1124.     NUMBER *q;
  1125.  
  1126.     v1 = &stack[-1];
  1127.     v2 = &stack[0];
  1128.     if (v1->v_type == V_ADDR)
  1129.         v1 = v1->v_addr;
  1130.     if (v2->v_type == V_ADDR)
  1131.         v2 = v2->v_addr;
  1132.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM))
  1133.         math_error("Non-numerics for and");
  1134.     q = qand(v1->v_num, v2->v_num);
  1135.     if (stack->v_type == V_NUM)
  1136.         qfree(stack->v_num);
  1137.     stack--;
  1138.     if (stack->v_type == V_NUM)
  1139.         qfree(stack->v_num);
  1140.     stack->v_num = q;
  1141.     stack->v_type = V_NUM;
  1142. }
  1143.  
  1144.  
  1145. static void
  1146. o_or()
  1147. {
  1148.     VALUE *v1, *v2;
  1149.     NUMBER *q;
  1150.  
  1151.     v1 = &stack[-1];
  1152.     v2 = &stack[0];
  1153.     if (v1->v_type == V_ADDR)
  1154.         v1 = v1->v_addr;
  1155.     if (v2->v_type == V_ADDR)
  1156.         v2 = v2->v_addr;
  1157.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM))
  1158.         math_error("Non-numerics for or");
  1159.     q = qor(v1->v_num, v2->v_num);
  1160.     if (stack->v_type == V_NUM)
  1161.         qfree(stack->v_num);
  1162.     stack--;
  1163.     if (stack->v_type == V_NUM)
  1164.         qfree(stack->v_num);
  1165.     stack->v_num = q;
  1166.     stack->v_type = V_NUM;
  1167. }
  1168.  
  1169.  
  1170. static void
  1171. o_not()
  1172. {
  1173.     VALUE *vp;
  1174.     int r;
  1175.  
  1176.     vp = stack;
  1177.     if (vp->v_type == V_ADDR)
  1178.         vp = vp->v_addr;
  1179.     r = testvalue(vp);
  1180.     freevalue(stack);
  1181.     stack->v_num = (r ? qlink(&_qzero_) : qlink(&_qone_));        
  1182.     stack->v_type = V_NUM;
  1183. }
  1184.  
  1185.  
  1186. static void
  1187. o_negate()
  1188. {
  1189.     VALUE *vp;
  1190.     NUMBER *q;
  1191.     VALUE tmp;
  1192.  
  1193.     vp = stack;
  1194.     if (vp->v_type == V_ADDR)
  1195.         vp = vp->v_addr;
  1196.     if (vp->v_type == V_NUM) {
  1197.         q = qneg(vp->v_num);
  1198.         if (stack->v_type == V_NUM)
  1199.             qfree(stack->v_num);
  1200.         stack->v_num = q;
  1201.         stack->v_type = V_NUM;
  1202.         return;
  1203.     }
  1204.     negvalue(vp, &tmp);
  1205.     freevalue(stack);
  1206.     *stack = tmp;
  1207. }
  1208.  
  1209.  
  1210. static void
  1211. o_invert()
  1212. {
  1213.     VALUE *vp;
  1214.     NUMBER *q;
  1215.     VALUE tmp;
  1216.  
  1217.     vp = stack;
  1218.     if (vp->v_type == V_ADDR)
  1219.         vp = vp->v_addr;
  1220.     if (vp->v_type == V_NUM) {
  1221.         q = qinv(vp->v_num);
  1222.         if (stack->v_type == V_NUM)
  1223.             qfree(stack->v_num);
  1224.         stack->v_num = q;
  1225.         stack->v_type = V_NUM;
  1226.         return;
  1227.     }
  1228.     invertvalue(vp, &tmp);
  1229.     freevalue(stack);
  1230.     *stack = tmp;
  1231. }
  1232.  
  1233.  
  1234. static void
  1235. o_scale()
  1236. {
  1237.     VALUE *v1, *v2;
  1238.     NUMBER *q;
  1239.     VALUE tmp;
  1240.  
  1241.     v1 = &stack[0];
  1242.     v2 = &stack[-1];
  1243.     if (v1->v_type == V_ADDR)
  1244.         v1 = v1->v_addr;
  1245.     if (v2->v_type == V_ADDR)
  1246.         v2 = v2->v_addr;
  1247.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
  1248.         scalevalue(v2, v1, &tmp);
  1249.         freevalue(stack--);
  1250.         freevalue(stack);
  1251.         *stack = tmp;
  1252.         return;
  1253.     }
  1254.     q = v1->v_num;
  1255.     if (qisfrac(q))
  1256.         math_error("Non-integral scaling factor");
  1257.     if (zge31b(q->num))
  1258.         math_error("Very large scaling factor");
  1259.     q = qscale(v2->v_num, qtoi(q));
  1260.     if (stack->v_type == V_NUM)
  1261.         qfree(stack->v_num);
  1262.     stack--;
  1263.     if (stack->v_type == V_NUM)
  1264.         qfree(stack->v_num);
  1265.     stack->v_num = q;
  1266.     stack->v_type = V_NUM;
  1267. }
  1268.  
  1269.  
  1270. static void
  1271. o_int()
  1272. {
  1273.     VALUE *vp;
  1274.     NUMBER *q;
  1275.     VALUE tmp;
  1276.  
  1277.     vp = stack;
  1278.     if (vp->v_type == V_ADDR)
  1279.         vp = vp->v_addr;
  1280.     if (vp->v_type == V_NUM) {
  1281.         if (qisint(vp->v_num) && (stack->v_type == V_NUM))
  1282.             return;
  1283.         q = qint(vp->v_num);
  1284.         if (stack->v_type == V_NUM)
  1285.             qfree(stack->v_num);
  1286.         stack->v_num = q;
  1287.         stack->v_type = V_NUM;
  1288.         return;
  1289.     }
  1290.     intvalue(vp, &tmp);
  1291.     freevalue(stack);
  1292.     *stack = tmp;
  1293. }
  1294.  
  1295.  
  1296. static void
  1297. o_frac()
  1298. {
  1299.     VALUE *vp;
  1300.     NUMBER *q;
  1301.     VALUE tmp;
  1302.  
  1303.     vp = stack;
  1304.     if (vp->v_type == V_ADDR)
  1305.         vp = vp->v_addr;
  1306.     if (vp->v_type == V_NUM) {
  1307.         q = qfrac(vp->v_num);
  1308.         if (stack->v_type == V_NUM)
  1309.             qfree(stack->v_num);
  1310.         stack->v_num = q;
  1311.         stack->v_type = V_NUM;
  1312.         return;
  1313.     }
  1314.     fracvalue(vp, &tmp);
  1315.     freevalue(stack);
  1316.     *stack = tmp;
  1317. }
  1318.  
  1319.  
  1320. static void
  1321. o_abs()
  1322. {
  1323.     VALUE *v1, *v2;
  1324.     NUMBER *q;
  1325.     VALUE tmp;
  1326.  
  1327.     v1 = &stack[-1];
  1328.     v2 = &stack[0];
  1329.     if (v1->v_type == V_ADDR)
  1330.         v1 = v1->v_addr;
  1331.     if (v2->v_type == V_ADDR)
  1332.         v2 = v2->v_addr;
  1333.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM) ||
  1334.         !qispos(v2->v_num))
  1335.     {
  1336.         absvalue(v1, v2, &tmp);
  1337.         freevalue(stack--);
  1338.         freevalue(stack);
  1339.         *stack = tmp;
  1340.         return;
  1341.     }
  1342.     if (stack->v_type == V_NUM)
  1343.         qfree(stack->v_num);
  1344.     stack--;
  1345.     if ((stack->v_type == V_NUM) && !qisneg(v1->v_num))
  1346.         return;
  1347.     q = qabs(v1->v_num);
  1348.     if (stack->v_type == V_NUM)
  1349.         qfree(stack->v_num);
  1350.     stack->v_num = q;
  1351.     stack->v_type = V_NUM;
  1352. }
  1353.  
  1354.  
  1355. static void
  1356. o_norm()
  1357. {
  1358.     VALUE *vp;
  1359.     NUMBER *q;
  1360.     VALUE tmp;
  1361.  
  1362.     vp = stack;
  1363.     if (vp->v_type == V_ADDR)
  1364.         vp = vp->v_addr;
  1365.     if (vp->v_type == V_NUM) {
  1366.         q = qsquare(vp->v_num);
  1367.         if (stack->v_type == V_NUM)
  1368.             qfree(stack->v_num);
  1369.         stack->v_num = q;
  1370.         stack->v_type = V_NUM;
  1371.         return;
  1372.     }
  1373.     normvalue(vp, &tmp);
  1374.     freevalue(stack);
  1375.     *stack = tmp;
  1376. }
  1377.  
  1378.  
  1379. static void
  1380. o_square()
  1381. {
  1382.     VALUE *vp;
  1383.     NUMBER *q;
  1384.     VALUE tmp;
  1385.  
  1386.     vp = stack;
  1387.     if (vp->v_type == V_ADDR)
  1388.         vp = vp->v_addr;
  1389.     if (vp->v_type == V_NUM) {
  1390.         q = qsquare(vp->v_num);
  1391.         if (stack->v_type == V_NUM)
  1392.             qfree(stack->v_num);
  1393.         stack->v_num = q;
  1394.         stack->v_type = V_NUM;
  1395.         return;
  1396.     }
  1397.     squarevalue(vp, &tmp);
  1398.     freevalue(stack);
  1399.     *stack = tmp;
  1400. }
  1401.  
  1402.  
  1403. static void
  1404. o_istype()
  1405. {
  1406.     VALUE *v1, *v2;
  1407.     int r;
  1408.  
  1409.     v1 = &stack[-1];
  1410.     v2 = &stack[0];
  1411.     if (v1->v_type == V_ADDR)
  1412.         v1 = v1->v_addr;
  1413.     if (v2->v_type == V_ADDR)
  1414.         v2 = v2->v_addr;
  1415.     if ((v1->v_type != V_OBJ) || (v2->v_type != V_OBJ))
  1416.         r = (v1->v_type == v2->v_type);
  1417.     else
  1418.         r = (v1->v_obj->o_actions == v2->v_obj->o_actions);
  1419.     freevalue(stack--);
  1420.     freevalue(stack);
  1421.     stack->v_num = itoq((long) r);
  1422.     stack->v_type = V_NUM;
  1423. }
  1424.  
  1425.  
  1426. static void
  1427. o_isint()
  1428. {
  1429.     VALUE *vp;
  1430.     NUMBER *q;
  1431.  
  1432.     vp = stack;
  1433.     if (vp->v_type == V_ADDR)
  1434.         vp = stack->v_addr;
  1435.     if (vp->v_type != V_NUM) {
  1436.         freevalue(stack);
  1437.         stack->v_num = qlink(&_qzero_);
  1438.         stack->v_type = V_NUM;
  1439.         return;
  1440.     }
  1441.     if (qisint(vp->v_num))
  1442.         q = qlink(&_qone_);
  1443.     else
  1444.         q = qlink(&_qzero_);
  1445.     if (stack->v_type == V_NUM)
  1446.         qfree(stack->v_num);
  1447.     stack->v_num = q;
  1448.     stack->v_type = V_NUM;
  1449. }
  1450.  
  1451.  
  1452. static void
  1453. o_isnum()
  1454. {
  1455.     VALUE *vp;
  1456.  
  1457.     vp = stack;
  1458.     if (vp->v_type == V_ADDR)
  1459.         vp = vp->v_addr;
  1460.     switch (vp->v_type) {
  1461.         case V_NUM:
  1462.             if (stack->v_type == V_NUM)
  1463.                 qfree(stack->v_num);
  1464.             break;
  1465.         case V_COM:
  1466.             if (stack->v_type == V_COM)
  1467.                 comfree(stack->v_com);
  1468.             break;
  1469.         default:
  1470.             freevalue(stack);
  1471.             stack->v_num = qlink(&_qzero_);
  1472.             stack->v_type = V_NUM;
  1473.             return;
  1474.     }
  1475.     stack->v_num = qlink(&_qone_);
  1476.     stack->v_type = V_NUM;
  1477. }
  1478.  
  1479.  
  1480. static void
  1481. o_ismat()
  1482. {
  1483.     VALUE *vp;
  1484.  
  1485.     vp = stack;
  1486.     if (vp->v_type == V_ADDR)
  1487.         vp = vp->v_addr;
  1488.     if (vp->v_type != V_MAT) {
  1489.         freevalue(stack);
  1490.         stack->v_num = qlink(&_qzero_);
  1491.         stack->v_type = V_NUM;
  1492.         return;
  1493.     }
  1494.     freevalue(stack);
  1495.     stack->v_type = V_NUM;
  1496.     stack->v_num = qlink(&_qone_);
  1497. }
  1498.  
  1499.  
  1500. static void
  1501. o_islist()
  1502. {
  1503.     VALUE *vp;
  1504.     int r;
  1505.  
  1506.     vp = stack;
  1507.     if (vp->v_type == V_ADDR)
  1508.         vp = vp->v_addr;
  1509.     r = (vp->v_type == V_LIST);
  1510.     freevalue(stack);
  1511.     stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
  1512.     stack->v_type = V_NUM;
  1513. }
  1514.  
  1515.  
  1516. static void
  1517. o_isobj()
  1518. {
  1519.     VALUE *vp;
  1520.     int r;
  1521.  
  1522.     vp = stack;
  1523.     if (vp->v_type == V_ADDR)
  1524.         vp = vp->v_addr;
  1525.     r = (vp->v_type == V_OBJ);
  1526.     freevalue(stack);
  1527.     stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
  1528.     stack->v_type = V_NUM;
  1529. }
  1530.  
  1531.  
  1532. static void
  1533. o_isstr()
  1534. {
  1535.     VALUE *vp;
  1536.     int r;
  1537.  
  1538.     vp = stack;
  1539.     if (vp->v_type == V_ADDR)
  1540.         vp = vp->v_addr;
  1541.     r = (vp->v_type == V_STR);
  1542.     freevalue(stack);
  1543.     stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
  1544.     stack->v_type = V_NUM;
  1545. }
  1546.  
  1547.  
  1548. static void
  1549. o_isfile()
  1550. {
  1551.     VALUE *vp;
  1552.     int r;
  1553.  
  1554.     vp = stack;
  1555.     if (vp->v_type == V_ADDR)
  1556.         vp = vp->v_addr;
  1557.     r = (vp->v_type == V_FILE);
  1558.     freevalue(stack);
  1559.     stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
  1560.     stack->v_type = V_NUM;
  1561. }
  1562.  
  1563.  
  1564. static void
  1565. o_isassoc()
  1566. {
  1567.     VALUE *vp;
  1568.     int r;
  1569.  
  1570.     vp = stack;
  1571.     if (vp->v_type == V_ADDR)
  1572.         vp = vp->v_addr;
  1573.     r = (vp->v_type == V_ASSOC);
  1574.     freevalue(stack);
  1575.     stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
  1576.     stack->v_type = V_NUM;
  1577. }
  1578.  
  1579.  
  1580. static void
  1581. o_issimple()
  1582. {
  1583.     VALUE *vp;
  1584.     int r;
  1585.  
  1586.     vp = stack;
  1587.     if (vp->v_type == V_ADDR)
  1588.         vp = vp->v_addr;
  1589.     r = 0;
  1590.     switch (vp->v_type) {
  1591.         case V_NULL:
  1592.         case V_NUM:
  1593.         case V_COM:
  1594.         case V_STR:
  1595.             r = 1;
  1596.     }
  1597.     freevalue(stack);
  1598.     stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
  1599.     stack->v_type = V_NUM;
  1600. }
  1601.  
  1602.  
  1603. static void
  1604. o_isodd()
  1605. {
  1606.     VALUE *vp;
  1607.  
  1608.     vp = stack;
  1609.     if (vp->v_type == V_ADDR)
  1610.         vp = vp->v_addr;
  1611.     if ((vp->v_type == V_NUM) && qisodd(vp->v_num)) {
  1612.         if (stack->v_type == V_NUM)
  1613.             qfree(stack->v_num);
  1614.         stack->v_num = qlink(&_qone_);
  1615.         stack->v_type = V_NUM;
  1616.         return;
  1617.     }
  1618.     freevalue(stack);
  1619.     stack->v_num = qlink(&_qzero_);
  1620.     stack->v_type = V_NUM;
  1621. }
  1622.  
  1623.  
  1624. static void
  1625. o_iseven()
  1626. {
  1627.     VALUE *vp;
  1628.  
  1629.     vp = stack;
  1630.     if (vp->v_type == V_ADDR)
  1631.         vp = vp->v_addr;
  1632.     if ((vp->v_type == V_NUM) && qiseven(vp->v_num)) {
  1633.         if (stack->v_type == V_NUM)
  1634.             qfree(stack->v_num);
  1635.         stack->v_num = qlink(&_qone_);
  1636.         stack->v_type = V_NUM;
  1637.         return;
  1638.     }
  1639.     freevalue(stack);
  1640.     stack->v_num = qlink(&_qzero_);
  1641.     stack->v_type = V_NUM;
  1642. }
  1643.  
  1644.  
  1645. static void
  1646. o_isreal()
  1647. {
  1648.     VALUE *vp;
  1649.  
  1650.     vp = stack;
  1651.     if (vp->v_type == V_ADDR)
  1652.         vp = vp->v_addr;
  1653.     if (vp->v_type == V_NUM) {
  1654.         if (stack->v_type == V_NUM)
  1655.             qfree(stack->v_num);
  1656.         stack->v_num = qlink(&_qone_);
  1657.         stack->v_type = V_NUM;
  1658.         return;
  1659.     }
  1660.     freevalue(stack);
  1661.     stack->v_num = qlink(&_qzero_);
  1662.     stack->v_type = V_NUM;
  1663. }
  1664.  
  1665.  
  1666. static void
  1667. o_isnull()
  1668. {
  1669.     VALUE *vp;
  1670.  
  1671.     vp = stack;
  1672.     if (vp->v_type == V_ADDR)
  1673.         vp = vp->v_addr;
  1674.     if (vp->v_type != V_NULL) {
  1675.         freevalue(stack);
  1676.         stack->v_num = qlink(&_qzero_);
  1677.         stack->v_type = V_NUM;
  1678.         return;
  1679.     }
  1680.     freevalue(stack);
  1681.     stack->v_num = qlink(&_qone_);
  1682.     stack->v_type = V_NUM;
  1683. }
  1684.  
  1685.  
  1686. static void
  1687. o_re()
  1688. {
  1689.     VALUE *vp;
  1690.     NUMBER *q;
  1691.  
  1692.     vp = stack;
  1693.     if (vp->v_type == V_ADDR)
  1694.         vp = vp->v_addr;
  1695.     if (vp->v_type == V_NUM) {
  1696.         if (stack->v_type == V_ADDR) {
  1697.             stack->v_num = qlink(vp->v_num);
  1698.             stack->v_type = V_NUM;
  1699.         }
  1700.         return;
  1701.     }
  1702.     if (vp->v_type != V_COM)
  1703.         math_error("Taking real part of non-number");
  1704.     q = qlink(vp->v_com->real);
  1705.     if (stack->v_type == V_COM)
  1706.         comfree(stack->v_com);
  1707.     stack->v_num = q;
  1708.     stack->v_type = V_NUM;
  1709. }
  1710.  
  1711.  
  1712. static void
  1713. o_im()
  1714. {
  1715.     VALUE *vp;
  1716.     NUMBER *q;
  1717.  
  1718.     vp = stack;
  1719.     if (vp->v_type == V_ADDR)
  1720.         vp = vp->v_addr;
  1721.     if (vp->v_type == V_NUM) {
  1722.         if (stack->v_type == V_NUM)
  1723.             qfree(stack->v_num);
  1724.         stack->v_num = qlink(&_qzero_);
  1725.         stack->v_type = V_NUM;
  1726.         return;
  1727.     }
  1728.     if (vp->v_type != V_COM)
  1729.         math_error("Taking imaginary part of non-number");
  1730.     q = qlink(vp->v_com->imag);
  1731.     if (stack->v_type == V_COM)
  1732.         comfree(stack->v_com);
  1733.     stack->v_num = q;
  1734.     stack->v_type = V_NUM;
  1735. }
  1736.  
  1737.  
  1738. static void
  1739. o_conjugate()
  1740. {
  1741.     VALUE *vp;
  1742.     VALUE tmp;
  1743.  
  1744.     vp = stack;
  1745.     if (vp->v_type == V_ADDR)
  1746.         vp = vp->v_addr;
  1747.     if (vp->v_type == V_NUM) {
  1748.         if (stack->v_type == V_ADDR) {
  1749.             stack->v_num = qlink(vp->v_num);
  1750.             stack->v_type = V_NUM;
  1751.         }
  1752.         return;
  1753.     }
  1754.     conjvalue(vp, &tmp);
  1755.     freevalue(stack);
  1756.     *stack = tmp;
  1757. }
  1758.  
  1759.  
  1760. static void
  1761. o_fiaddr()
  1762. {
  1763.     register MATRIX *m;    /* current matrix element */
  1764.     NUMBER *q;        /* index value */
  1765.     LIST *lp;        /* list header */
  1766.     ASSOC *ap;        /* association header */
  1767.     VALUE *vp;        /* stack value */
  1768.     long index;        /* index value as an integer */
  1769.  
  1770.     vp = stack;
  1771.     if (vp->v_type == V_ADDR)
  1772.         vp = vp->v_addr;
  1773.     if (vp->v_type != V_NUM)
  1774.         math_error("Fast indexing by non-number");
  1775.     q = vp->v_num;
  1776.     if (qisfrac(q))
  1777.         math_error("Fast indexing by non-integer");
  1778.     index = qtoi(q);
  1779.     if (zge31b(q->num) || (index < 0))
  1780.         math_error("Index out of range for fast indexing");
  1781.     if (stack->v_type == V_NUM)
  1782.         qfree(q);
  1783.     stack--;
  1784.     vp = stack;
  1785.     if (vp->v_type != V_ADDR)
  1786.         math_error("Bad value for fast indexing");
  1787.     switch (vp->v_addr->v_type) {
  1788.         case V_OBJ:
  1789.             if (index >= vp->v_addr->v_obj->o_actions->count)
  1790.                 math_error("Index out of bounds for object");
  1791.             vp->v_addr = vp->v_addr->v_obj->o_table + index;
  1792.             break;
  1793.         case V_MAT:
  1794.             m = vp->v_addr->v_mat;
  1795.             if (index >= m->m_size)
  1796.                 math_error("Index out of bounds for matrix");
  1797.             vp->v_addr = m->m_table + index;
  1798.             break;
  1799.         case V_LIST:
  1800.             lp = vp->v_addr->v_list;
  1801.             vp->v_addr = listfindex(lp, index);
  1802.             if (vp->v_addr == NULL)
  1803.                 math_error("Index out of bounds for list");
  1804.             break;
  1805.         case V_ASSOC:
  1806.             ap = vp->v_addr->v_assoc;
  1807.             vp->v_addr = assocfindex(ap, index);
  1808.             if (vp->v_addr == NULL)
  1809.                 math_error("Index out of bounds for association");
  1810.             break;
  1811.         default:
  1812.             math_error("Bad variable type for fast indexing");
  1813.     }
  1814. }
  1815.  
  1816.  
  1817. static void
  1818. o_fivalue()
  1819. {
  1820.     (void) o_fiaddr();
  1821.     (void) o_getvalue();
  1822. }
  1823.  
  1824.  
  1825. static void
  1826. o_sgn()
  1827. {
  1828.     VALUE *vp;
  1829.     NUMBER *q;
  1830.     VALUE val;
  1831.  
  1832.     vp = stack;
  1833.     if (vp->v_type == V_ADDR)
  1834.         vp = vp->v_addr;
  1835.     switch (vp->v_type) {
  1836.         case V_NUM:
  1837.             q = qsign(vp->v_num);
  1838.             if (stack->v_type == V_NUM)
  1839.                 qfree(vp->v_num);
  1840.             stack->v_num = q;
  1841.             stack->v_type = V_NUM;
  1842.             break;
  1843.         case V_OBJ:
  1844.             val = objcall(OBJ_SGN, vp, NULL_VALUE, NULL_VALUE);
  1845.             q = itoq(val.v_int);
  1846.             freevalue(stack);
  1847.             stack->v_num = q;
  1848.             stack->v_type = V_NUM;
  1849.             break;
  1850.         default:
  1851.             math_error("Bad value for sgn");
  1852.     }
  1853. }
  1854.  
  1855.  
  1856. static void
  1857. o_numerator()
  1858. {
  1859.     VALUE *vp;
  1860.     NUMBER *q;
  1861.  
  1862.     vp = stack;
  1863.     if (vp->v_type == V_ADDR)
  1864.         vp = vp->v_addr;
  1865.     if (vp->v_type != V_NUM)
  1866.         math_error("Numerator of non-number");
  1867.     if ((stack->v_type == V_NUM) && qisint(vp->v_num))
  1868.         return;
  1869.     q = qnum(vp->v_num);
  1870.     if (stack->v_type == V_NUM)
  1871.         qfree(stack->v_num);
  1872.     stack->v_num = q;
  1873.     stack->v_type = V_NUM;
  1874. }
  1875.  
  1876.  
  1877. static void
  1878. o_denominator()
  1879. {
  1880.     VALUE *vp;
  1881.     NUMBER *q;
  1882.  
  1883.     vp = stack;
  1884.     if (vp->v_type == V_ADDR)
  1885.         vp = vp->v_addr;
  1886.     if (vp->v_type != V_NUM)
  1887.         math_error("Denominator of non-number");
  1888.     q = qden(vp->v_num);
  1889.     if (stack->v_type == V_NUM)
  1890.         qfree(stack->v_num);
  1891.     stack->v_num = q;
  1892.     stack->v_type = V_NUM;
  1893. }
  1894.  
  1895.  
  1896. static void
  1897. o_duplicate()
  1898. {
  1899.     copyvalue(stack, stack + 1);
  1900.     stack++;
  1901. }
  1902.  
  1903.  
  1904. static void
  1905. o_dupvalue()
  1906. {
  1907.     if (stack->v_type == V_ADDR)
  1908.         copyvalue(stack->v_addr, stack + 1);
  1909.     else
  1910.         copyvalue(stack, stack + 1);
  1911.     stack++;
  1912. }
  1913.  
  1914.  
  1915. static void
  1916. o_pop()
  1917. {
  1918.     freevalue(stack--);
  1919. }
  1920.  
  1921.  
  1922. static void
  1923. o_return()
  1924. {
  1925. }
  1926.  
  1927.  
  1928. /*ARGSUSED*/
  1929. static void
  1930. o_jumpeq(fp, dojump)
  1931.     FUNC *fp;
  1932.     BOOL *dojump;
  1933. {
  1934.     VALUE *vp;
  1935.     int i;            /* result of comparison */
  1936.  
  1937.     vp = stack;
  1938.     if (vp->v_type == V_ADDR)
  1939.         vp = vp->v_addr;
  1940.     if (vp->v_type == V_NUM) {
  1941.         i = !qiszero(vp->v_num);
  1942.         if (stack->v_type == V_NUM)
  1943.             qfree(stack->v_num);
  1944.     } else {
  1945.         i = testvalue(vp);
  1946.         freevalue(stack);
  1947.     }
  1948.     stack--;
  1949.     if (!i)
  1950.         *dojump = TRUE;
  1951. }
  1952.  
  1953.  
  1954. /*ARGSUSED*/
  1955. static void
  1956. o_jumpne(fp, dojump)
  1957.     FUNC *fp;
  1958.     BOOL *dojump;
  1959. {
  1960.     VALUE *vp;
  1961.     int i;            /* result of comparison */
  1962.  
  1963.     vp = stack;
  1964.     if (vp->v_type == V_ADDR)
  1965.         vp = vp->v_addr;
  1966.     if (vp->v_type == V_NUM) {
  1967.         i = !qiszero(vp->v_num);
  1968.         if (stack->v_type == V_NUM)
  1969.             qfree(stack->v_num);
  1970.     } else {
  1971.         i = testvalue(vp);
  1972.         freevalue(stack);
  1973.     }
  1974.     stack--;
  1975.     if (i)
  1976.         *dojump = TRUE;
  1977. }
  1978.  
  1979.  
  1980. /*ARGSUSED*/
  1981. static void
  1982. o_condorjump(fp, dojump)
  1983.     FUNC *fp;
  1984.     BOOL *dojump;
  1985. {
  1986.     VALUE *vp;
  1987.  
  1988.     vp = stack;
  1989.     if (vp->v_type == V_ADDR)
  1990.         vp = vp->v_addr;
  1991.     if (vp->v_type == V_NUM) {
  1992.         if (!qiszero(vp->v_num)) {
  1993.             *dojump = TRUE;
  1994.             return;
  1995.         }
  1996.         if (stack->v_type == V_NUM)
  1997.             qfree(stack->v_num);
  1998.         stack--;
  1999.         return;
  2000.     }
  2001.     if (testvalue(vp))
  2002.         *dojump = TRUE;
  2003.     else
  2004.         freevalue(stack--);
  2005. }
  2006.  
  2007.  
  2008. /*ARGSUSED*/
  2009. static void
  2010. o_condandjump(fp, dojump)
  2011.     FUNC *fp;
  2012.     BOOL *dojump;
  2013. {
  2014.     VALUE *vp;
  2015.  
  2016.     vp = stack;
  2017.     if (vp->v_type == V_ADDR)
  2018.         vp = vp->v_addr;
  2019.     if (vp->v_type == V_NUM) {
  2020.         if (qiszero(vp->v_num)) {
  2021.             *dojump = TRUE;
  2022.             return;
  2023.         }
  2024.         if (stack->v_type == V_NUM)
  2025.             qfree(stack->v_num);
  2026.         stack--;
  2027.         return;
  2028.     }
  2029.     if (!testvalue(vp))
  2030.         *dojump = TRUE;
  2031.     else
  2032.         freevalue(stack--);
  2033. }
  2034.  
  2035.  
  2036. /*
  2037.  * Compare the top two values on the stack for equality and jump if they are
  2038.  * different, popping off the top element, leaving the first one on the stack.
  2039.  * If they are equal, pop both values and do not jump.
  2040.  */
  2041. /*ARGSUSED*/
  2042. static void
  2043. o_casejump(fp, dojump)
  2044.     FUNC *fp;
  2045.     BOOL *dojump;
  2046. {
  2047.     VALUE *v1, *v2;
  2048.     int r;
  2049.  
  2050.     v1 = &stack[-1];
  2051.     v2 = &stack[0];
  2052.     if (v1->v_type == V_ADDR)
  2053.         v1 = v1->v_addr;
  2054.     if (v2->v_type == V_ADDR)
  2055.         v2 = v2->v_addr;
  2056.     r = comparevalue(v1, v2);
  2057.     freevalue(stack--);
  2058.     if (r)
  2059.         *dojump = TRUE;
  2060.     else
  2061.         freevalue(stack--);
  2062. }
  2063.  
  2064.  
  2065. /*ARGSUSED*/
  2066. static void
  2067. o_jump(fp, dojump)
  2068.     FUNC *fp;
  2069.     BOOL *dojump;
  2070. {
  2071.     *dojump = TRUE;
  2072. }
  2073.  
  2074.  
  2075. static void
  2076. o_usercall(fp, index, argcount)
  2077.     FUNC *fp;
  2078.     long index, argcount;
  2079. {
  2080.     fp = findfunc(index);
  2081.     if (fp == NULL)
  2082.         math_error("Function \"%s\" is undefined", namefunc(index));
  2083.     calculate(fp, (int) argcount);
  2084. }
  2085.  
  2086.  
  2087. /*ARGSUSED*/
  2088. static void
  2089. o_call(fp, index, argcount)
  2090.     FUNC *fp;
  2091.     long index, argcount;
  2092. {
  2093.     VALUE result;
  2094.  
  2095.     result = builtinfunc(index, (int) argcount, stack);
  2096.     while (--argcount >= 0)
  2097.         freevalue(stack--);
  2098.     stack++;
  2099.     *stack = result;
  2100. }
  2101.  
  2102.  
  2103. static void
  2104. o_getvalue()
  2105. {
  2106.     if (stack->v_type == V_ADDR)
  2107.         copyvalue(stack->v_addr, stack);
  2108. }
  2109.  
  2110.  
  2111. static void
  2112. o_cmp()
  2113. {
  2114.     VALUE *v1, *v2;
  2115.     int r;
  2116.  
  2117.     v1 = &stack[-1];
  2118.     v2 = &stack[0];
  2119.     if (v1->v_type == V_ADDR)
  2120.         v1 = v1->v_addr;
  2121.     if (v2->v_type == V_ADDR)
  2122.         v2 = v2->v_addr;
  2123.     r = relvalue(v1, v2);
  2124.     freevalue(stack--);
  2125.     freevalue(stack);
  2126.     stack->v_num = itoq((long) r);
  2127.     stack->v_type = V_NUM;
  2128. }
  2129.  
  2130.  
  2131. static void
  2132. o_eq()
  2133. {
  2134.     VALUE *v1, *v2;
  2135.     int r;
  2136.  
  2137.     v1 = &stack[-1];
  2138.     v2 = &stack[0];
  2139.     if (v1->v_type == V_ADDR)
  2140.         v1 = v1->v_addr;
  2141.     if (v2->v_type == V_ADDR)
  2142.         v2 = v2->v_addr;
  2143.     r = comparevalue(v1, v2);
  2144.     freevalue(stack--);
  2145.     freevalue(stack);
  2146.     stack->v_num = itoq((long) (r == 0));
  2147.     stack->v_type = V_NUM;
  2148. }
  2149.  
  2150.  
  2151. static void
  2152. o_ne()
  2153. {
  2154.     VALUE *v1, *v2;
  2155.     int r;
  2156.  
  2157.     v1 = &stack[-1];
  2158.     v2 = &stack[0];
  2159.     if (v1->v_type == V_ADDR)
  2160.         v1 = v1->v_addr;
  2161.     if (v2->v_type == V_ADDR)
  2162.         v2 = v2->v_addr;
  2163.     r = comparevalue(v1, v2);
  2164.     freevalue(stack--);
  2165.     freevalue(stack);
  2166.     stack->v_num = itoq((long) (r != 0));
  2167.     stack->v_type = V_NUM;
  2168. }
  2169.  
  2170.  
  2171. static void
  2172. o_le()
  2173. {
  2174.     VALUE *v1, *v2;
  2175.     int r;
  2176.  
  2177.     v1 = &stack[-1];
  2178.     v2 = &stack[0];
  2179.     if (v1->v_type == V_ADDR)
  2180.         v1 = v1->v_addr;
  2181.     if (v2->v_type == V_ADDR)
  2182.         v2 = v2->v_addr;
  2183.     r = relvalue(v1, v2);
  2184.     freevalue(stack--);
  2185.     freevalue(stack);
  2186.     stack->v_num = itoq((long) (r <= 0));
  2187.     stack->v_type = V_NUM;
  2188. }
  2189.  
  2190.  
  2191. static void
  2192. o_ge()
  2193. {
  2194.     VALUE *v1, *v2;
  2195.     int r;
  2196.  
  2197.     v1 = &stack[-1];
  2198.     v2 = &stack[0];
  2199.     if (v1->v_type == V_ADDR)
  2200.         v1 = v1->v_addr;
  2201.     if (v2->v_type == V_ADDR)
  2202.         v2 = v2->v_addr;
  2203.     r = relvalue(v1, v2);
  2204.     freevalue(stack--);
  2205.     freevalue(stack);
  2206.     stack->v_num = itoq((long) (r >= 0));
  2207.     stack->v_type = V_NUM;
  2208. }
  2209.  
  2210.  
  2211. static void
  2212. o_lt()
  2213. {
  2214.     VALUE *v1, *v2;
  2215.     int r;
  2216.  
  2217.     v1 = &stack[-1];
  2218.     v2 = &stack[0];
  2219.     if (v1->v_type == V_ADDR)
  2220.         v1 = v1->v_addr;
  2221.     if (v2->v_type == V_ADDR)
  2222.         v2 = v2->v_addr;
  2223.     r = relvalue(v1, v2);
  2224.     freevalue(stack--);
  2225.     freevalue(stack);
  2226.     stack->v_num = itoq((long) (r < 0));
  2227.     stack->v_type = V_NUM;
  2228. }
  2229.  
  2230.  
  2231. static void
  2232. o_gt()
  2233. {
  2234.     VALUE *v1, *v2;
  2235.     int r;
  2236.  
  2237.     v1 = &stack[-1];
  2238.     v2 = &stack[0];
  2239.     if (v1->v_type == V_ADDR)
  2240.         v1 = v1->v_addr;
  2241.     if (v2->v_type == V_ADDR)
  2242.         v2 = v2->v_addr;
  2243.     r = relvalue(v1, v2);
  2244.     freevalue(stack--);
  2245.     freevalue(stack);
  2246.     stack->v_num = itoq((long) (r > 0));
  2247.     stack->v_type = V_NUM;
  2248. }
  2249.  
  2250.  
  2251. static void
  2252. o_preinc()
  2253. {
  2254.     NUMBER *q, **np;
  2255.     VALUE *vp, tmp;
  2256.  
  2257.     if (stack->v_type != V_ADDR)
  2258.         math_error("Preincrementing non-variable");
  2259.     if (stack->v_addr->v_type == V_NUM) {
  2260.         np = &stack->v_addr->v_num;
  2261.         q = qinc(*np);
  2262.         qfree(*np);
  2263.         *np = q;
  2264.         stack->v_type = V_NUM;
  2265.         stack->v_num = qlink(q);
  2266.         return;
  2267.     }
  2268.     vp = stack->v_addr;
  2269.     incvalue(vp, &tmp);
  2270.     freevalue(vp);
  2271.     *vp = tmp;
  2272.     copyvalue(&tmp, stack);
  2273. }
  2274.  
  2275.  
  2276. static void
  2277. o_predec()
  2278. {
  2279.     NUMBER *q, **np;
  2280.     VALUE *vp, tmp;
  2281.  
  2282.     if (stack->v_type != V_ADDR)
  2283.         math_error("Predecrementing non-variable");
  2284.     if (stack->v_addr->v_type == V_NUM) {
  2285.         np = &stack->v_addr->v_num;
  2286.         q = qdec(*np);
  2287.         qfree(*np);
  2288.         *np = q;
  2289.         stack->v_type = V_NUM;
  2290.         stack->v_num = qlink(q);
  2291.         return;
  2292.     }
  2293.     vp = stack->v_addr;
  2294.     decvalue(vp, &tmp);
  2295.     freevalue(vp);
  2296.     *vp = tmp;
  2297.     copyvalue(&tmp, stack);
  2298. }
  2299.  
  2300.  
  2301. static void
  2302. o_postinc()
  2303. {
  2304.     NUMBER *q, **np;
  2305.     VALUE *vp, tmp;
  2306.  
  2307.     if (stack->v_type != V_ADDR)
  2308.         math_error("Postincrementing non-variable");
  2309.     if (stack->v_addr->v_type == V_NUM) {
  2310.         np = &stack->v_addr->v_num;
  2311.         q = *np;
  2312.         *np = qinc(q);
  2313.         stack->v_type = V_NUM;
  2314.         stack->v_num = q;
  2315.         return;
  2316.     }
  2317.     vp = stack->v_addr;
  2318.     tmp = *vp;
  2319.     incvalue(&tmp, vp);
  2320.     *stack = tmp;
  2321. }
  2322.  
  2323.  
  2324. static void
  2325. o_postdec()
  2326. {
  2327.     NUMBER *q, **np;
  2328.     VALUE *vp, tmp;
  2329.  
  2330.     if (stack->v_type != V_ADDR)
  2331.         math_error("Postdecrementing non-variable");
  2332.     if (stack->v_addr->v_type == V_NUM) {
  2333.         np = &stack->v_addr->v_num;
  2334.         q = *np;
  2335.         *np = qdec(q);
  2336.         stack->v_type = V_NUM;
  2337.         stack->v_num = q;
  2338.         return;
  2339.     }
  2340.     vp = stack->v_addr;
  2341.     tmp = *vp;
  2342.     decvalue(&tmp, vp);
  2343.     *stack = tmp;
  2344. }
  2345.  
  2346.  
  2347. static void
  2348. o_leftshift()
  2349. {
  2350.     VALUE *v1, *v2;
  2351.     VALUE tmp;
  2352.  
  2353.     v1 = &stack[-1];
  2354.     v2 = &stack[0];
  2355.     if (v1->v_type == V_ADDR)
  2356.         v1 = v1->v_addr;
  2357.     if (v2->v_type == V_ADDR)
  2358.         v2 = v2->v_addr;
  2359.     shiftvalue(v1, v2, FALSE, &tmp);
  2360.     freevalue(stack--);
  2361.     freevalue(stack);
  2362.     *stack = tmp;
  2363. }
  2364.  
  2365.  
  2366. static void
  2367. o_rightshift()
  2368. {
  2369.     VALUE *v1, *v2;
  2370.     VALUE tmp;
  2371.  
  2372.     v1 = &stack[-1];
  2373.     v2 = &stack[0];
  2374.     if (v1->v_type == V_ADDR)
  2375.         v1 = v1->v_addr;
  2376.     if (v2->v_type == V_ADDR)
  2377.         v2 = v2->v_addr;
  2378.     shiftvalue(v1, v2, TRUE, &tmp);
  2379.     freevalue(stack--);
  2380.     freevalue(stack);
  2381.     *stack = tmp;
  2382. }
  2383.  
  2384.  
  2385. /*ARGSUSED*/
  2386. static void
  2387. o_debug(fp, line)
  2388.     FUNC *fp;
  2389.     long line;
  2390. {
  2391.     funcline = line;
  2392.     if (abortlevel >= ABORT_STATEMENT)
  2393.         math_error("Calculation aborted at statement boundary");
  2394. }
  2395.  
  2396.  
  2397. static void
  2398. o_printresult()
  2399. {
  2400.     VALUE *vp;
  2401.  
  2402.     vp = stack;
  2403.     if (vp->v_type == V_ADDR)
  2404.         vp = vp->v_addr;
  2405.     if (vp->v_type != V_NULL) {
  2406.         if (tab_ok)
  2407.             math_chr('\t');
  2408.         printvalue(vp, PRINT_UNAMBIG);
  2409.         math_chr('\n');
  2410.         math_flush();
  2411.     }
  2412.     freevalue(stack--);
  2413. }
  2414.  
  2415.  
  2416. /*ARGSUSED*/
  2417. static void
  2418. o_print(fp, flags)
  2419.     FUNC *fp;
  2420.     long flags;
  2421. {
  2422.     VALUE *vp;
  2423.  
  2424.     vp = stack;
  2425.     if (vp->v_type == V_ADDR)
  2426.         vp = vp->v_addr;
  2427.     printvalue(vp, (int) flags);
  2428.     freevalue(stack--);
  2429.     if (traceflags & TRACE_OPCODES)
  2430.         printf("\n");
  2431.     math_flush();
  2432. }
  2433.  
  2434.  
  2435. static void
  2436. o_printeol()
  2437. {
  2438.     math_chr('\n');
  2439.     math_flush();
  2440. }
  2441.  
  2442.  
  2443. static void
  2444. o_printspace()
  2445. {
  2446.     math_chr(' ');
  2447.     if (traceflags & TRACE_OPCODES)
  2448.         printf("\n");
  2449. }
  2450.  
  2451.  
  2452. /*ARGSUSED*/
  2453. static void
  2454. o_printstring(fp, cp)
  2455.     FUNC *fp;
  2456.     char *cp;
  2457. {
  2458.     math_str(cp);
  2459.     if (traceflags & TRACE_OPCODES)
  2460.         printf("\n");
  2461.     math_flush();
  2462. }
  2463.  
  2464.  
  2465. static void
  2466. o_zero()
  2467. {
  2468.     stack++;
  2469.     stack->v_type = V_NUM;
  2470.     stack->v_num = qlink(&_qzero_);
  2471. }
  2472.  
  2473.  
  2474. static void
  2475. o_one()
  2476. {
  2477.     stack++;
  2478.     stack->v_type = V_NUM;
  2479.     stack->v_num = qlink(&_qone_);
  2480. }
  2481.  
  2482.  
  2483. static void
  2484. o_save(fp)
  2485.     FUNC *fp;
  2486. {
  2487.     VALUE *vp;
  2488.  
  2489.     vp = stack;
  2490.     if (vp->v_type == V_ADDR)
  2491.         vp = vp->v_addr;
  2492.     freevalue(&fp->f_savedvalue);
  2493.     copyvalue(vp, &fp->f_savedvalue);
  2494. }
  2495.  
  2496.  
  2497. static void
  2498. o_oldvalue()
  2499. {
  2500.     copyvalue(&oldvalue, ++stack);
  2501. }
  2502.  
  2503.  
  2504. static void
  2505. o_quit(fp, cp)
  2506.     FUNC *fp;
  2507.     char *cp;
  2508. {
  2509.     if ((fp->f_name[0] == '*') && (fp->f_name[1] == '\0')) {
  2510.         if (cp)
  2511.             printf("%s\n", cp);
  2512.         while (stack > stackarray) {
  2513.             freevalue(stack--);
  2514.         }
  2515.         freevalue(stackarray);
  2516.         exit(0);
  2517.     }
  2518.     if (cp)
  2519.         math_error("%s", cp);
  2520.     math_error("quit statement executed");
  2521. }
  2522.  
  2523.  
  2524. static void
  2525. o_getepsilon()
  2526. {
  2527.     stack++;
  2528.     stack->v_type = V_NUM;
  2529.     stack->v_num = qlink(_epsilon_);
  2530. }
  2531.  
  2532.  
  2533. static void
  2534. o_setepsilon()
  2535. {
  2536.     VALUE *vp;
  2537.     NUMBER *newep;
  2538.  
  2539.     vp = &stack[0];
  2540.     if (vp->v_type == V_ADDR)
  2541.         vp = vp->v_addr;
  2542.     if (vp->v_type != V_NUM)
  2543.         math_error("Non-numeric for epsilon");
  2544.     newep = vp->v_num;
  2545.     stack->v_num = qlink(_epsilon_);
  2546.     setepsilon(newep);
  2547.     qfree(newep);
  2548. }
  2549.  
  2550.  
  2551. static void
  2552. o_setconfig()
  2553. {
  2554.     int type;
  2555.     VALUE *v1, *v2;
  2556.     VALUE tmp;
  2557.  
  2558.     v1 = &stack[-1];
  2559.     v2 = &stack[0];
  2560.     if (v1->v_type == V_ADDR)
  2561.         v1 = v1->v_addr;
  2562.     if (v2->v_type == V_ADDR)
  2563.         v2 = v2->v_addr;
  2564.     if (v1->v_type != V_STR)
  2565.         math_error("Non-string for config");
  2566.     type = configtype(v1->v_str);
  2567.     if (type < 0)
  2568.         math_error("Unknown config name \"%s\"", v1->v_str);
  2569.     getconfig(type, &tmp);
  2570.     setconfig(type, v2);
  2571.     freevalue(stack--);
  2572.     freevalue(stack);
  2573.     *stack = tmp;
  2574. }
  2575.  
  2576.  
  2577. static void
  2578. o_getconfig()
  2579. {
  2580.     int type;
  2581.     VALUE *vp;
  2582.  
  2583.     vp = &stack[0];
  2584.     if (vp->v_type == V_ADDR)
  2585.         vp = vp->v_addr;
  2586.     if (vp->v_type != V_STR)
  2587.         math_error("Non-string for config");
  2588.     type = configtype(vp->v_str);
  2589.     if (type < 0)
  2590.         math_error("Unknown config name \"%s\"", vp->v_str);
  2591.     freevalue(stack);
  2592.     getconfig(type, stack);
  2593. }
  2594.  
  2595.  
  2596. /*
  2597.  * Set the 'old' value to the last value saved during the calculation.
  2598.  */
  2599. void
  2600. updateoldvalue(fp)
  2601.     FUNC *fp;
  2602. {
  2603.     if (fp->f_savedvalue.v_type == V_NULL)
  2604.         return;
  2605.     freevalue(&oldvalue);
  2606.     oldvalue = fp->f_savedvalue;
  2607.     fp->f_savedvalue.v_type = V_NULL;
  2608. }
  2609.  
  2610.  
  2611. /*
  2612.  * Routine called on any runtime error, to complain about it (with possible
  2613.  * arguments), and then longjump back to the top level command scanner.
  2614.  */
  2615. #ifdef VARARGS
  2616. # define VA_ALIST fmt, va_alist
  2617. # define VA_DCL char *fmt; va_dcl
  2618. #else
  2619. # if defined(__STDC__) && __STDC__ == 1
  2620. #  define VA_ALIST char *fmt, ...
  2621. #  define VA_DCL
  2622. # else
  2623. #  define VA_ALIST fmt
  2624. #  define VA_DCL char *fmt;
  2625. # endif
  2626. #endif
  2627. /*VARARGS*/
  2628. void
  2629. math_error(VA_ALIST)
  2630.     VA_DCL
  2631. {
  2632.     va_list ap;
  2633.     char buf[MAXERROR+1];
  2634.  
  2635.     if (funcname && (*funcname != '*'))
  2636.         fprintf(stderr, "\"%s\": ", funcname);
  2637.     if (funcline && ((funcname && (*funcname != '*')) || !inputisterminal()))
  2638.         fprintf(stderr, "line %ld: ", funcline);
  2639. #ifdef VARARGS
  2640.     va_start(ap);
  2641. #else
  2642.     va_start(ap, fmt);
  2643. #endif
  2644.     vsprintf(buf, fmt, ap);
  2645.     va_end(ap);
  2646.     fprintf(stderr, "%s\n", buf);
  2647.     funcname = NULL;
  2648.     longjmp(jmpbuf, 1);
  2649. }
  2650.  
  2651. /* END CODE */
  2652.